home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / WINDOWS / WXLSLIB.ARJ / INSPECT.LSP < prev    next >
Text File  |  1992-02-20  |  8KB  |  190 lines
  1. (provide "inspect")
  2.  
  3. ;;;
  4. ;;;
  5. ;;; Inspect Dialog Prototype
  6. ;;;
  7. ;;;
  8.  
  9. (defproto inspect-dialog-proto '(data editable) () dialog-proto)
  10.  
  11. (defmeth inspect-dialog-proto :isnew (d &key (title "Inspect") edit)
  12.   (setf (slot-value 'data) d)
  13.   (setf (slot-value 'editable) edit)
  14.   (let ((items (append (send self :make-items)
  15.                        (if edit 
  16.                            (list (send button-item-proto :new "Edit" 
  17.                                        :action
  18.                                        #'(lambda () 
  19.                                            (send self :edit-selection))))))))
  20.     (call-next-method items :title title :type 'modeless :go-away t)))
  21.  
  22. (defmeth inspect-dialog-proto :make-items ()
  23.   (let ((data (slot-value 'data)))
  24.     (list (send text-item-proto :new (format nil "type:  ~s" (type-of data)))
  25.           (send text-item-proto :new (format nil "value: ~s" data)))))
  26.  
  27. (defmeth inspect-dialog-proto :edit-selection () (sysbeep))
  28.  
  29. ;;;
  30. ;;;
  31. ;;; Inspect Symbol Dialog Proto
  32. ;;;
  33. ;;;
  34.  
  35. (defproto inspect-symbol-dialog-proto '(list-item) () inspect-dialog-proto)
  36.  
  37. (defmeth inspect-symbol-dialog-proto :isnew (d &key (title "Inspect") edit)
  38.   (if (not (symbolp d)) (error "not a symbol"))
  39.   (call-next-method d :title title :editable edit))
  40.  
  41. (defmeth inspect-symbol-dialog-proto :make-items ()
  42.   (let* ((data (slot-value 'data))
  43.          (strings (list (format nil "name:      ~s" (symbol-name data))
  44.                         (format nil "value:      ~s" 
  45.                                (if (boundp data) 
  46.                                    (symbol-value data) '*unbound*))
  47.                         (format nil "function: ~s" 
  48.                                 (if (fboundp data)
  49.                                     (symbol-function data) '*unbound*))
  50.                         (format nil "plist:        ~s" (symbol-plist data)))))
  51.     (setf (slot-value 'list-item)
  52.           (send list-item-proto :new strings 
  53.                 :action    (let ((d self))
  54.                           #'(lambda (double) 
  55.                                (if double (send d :inspect-selection))))))
  56.     (list (send text-item-proto :new (format nil "type:  ~s" (type-of data)))
  57.           (slot-value 'list-item))))
  58.  
  59. (defmeth inspect-symbol-dialog-proto :inspect-selection ()
  60.   (let ((data (slot-value 'data))
  61.         (editable (slot-value 'editable)))
  62.     (case (send (slot-value 'list-item) :selection)
  63.           (0 (inspect (symbol-name data)))
  64.           (1 (if (boundp data) 
  65.                  (inspect (symbol-value data) :editable editable)))
  66.           (2 (if (fboundp data) 
  67.                  (inspect (symbol-function data) :editable editable)))
  68.           (3 (if (symbol-plist data) 
  69.                  (inspect (symbol-plist data) :editable editable))))))
  70.  
  71. (defmeth inspect-symbol-dialog-proto :edit-selection ()
  72.   (let ((data (slot-value 'data)))
  73.     (case (send list-item :selection)
  74.           (1 (let ((v (get-value-dialog "New symbol-value")))
  75.                (when v 
  76.                      (setf (symbol-value data) (car v))
  77.                      (send list-item :set-text 1 
  78.                            (format nil "value:      ~s"  
  79.                                    (symbol-value data))))))
  80.           (2 (let ((v (get-value-dialog "New symbol-function")))
  81.                (when v 
  82.                      (setf (symbol-function data) (car v))
  83.                      (send list-item :set-text 2 
  84.                            (format nil "function: ~s" 
  85.                                    (symbol-function data))))))
  86.           (3 (let ((v (get-value-dialog "New symbol-plist")))
  87.                (when v
  88.                      (setf (symbol-plist data) (car v))
  89.                      (send list-item :set-text 3 
  90.                            (format nil "plist:        ~s"
  91.                                    (symbol-plist data)))))))))
  92.  
  93. ;;;
  94. ;;;
  95. ;;; Inspect Sequence Dialog proto
  96. ;;;
  97. ;;;
  98.  
  99. (defproto inspect-sequence-dialog-proto '(list-item) () inspect-dialog-proto)
  100.  
  101. (defmeth inspect-sequence-dialog-proto :isnew 
  102.   (d &key (title "Inspect") edit)
  103.   (if (not (or (consp d) (vectorp d))) (error "not a sequence"))
  104.   (call-next-method d :title title :editable edit))
  105.  
  106. (defmeth inspect-sequence-dialog-proto :make-items ()
  107.   (let* ((data (slot-value 'data))
  108.          (strings (map-elements #'(lambda (x) (format nil "~s" x)) data)))
  109.     (setf (slot-value 'list-item)
  110.           (send list-item-proto :new strings 
  111.                 :action    (let ((d self))
  112.                           #'(lambda (double) 
  113.                                     (if double 
  114.                                         (send d :inspect-selection))))))
  115.     (list (send text-item-proto :new 
  116.                 (format nil "type:    ~s" (type-of data)))
  117.           (send text-item-proto :new
  118.                 (format nil "length:  ~s" (length data)))
  119.           (slot-value 'list-item))))
  120.  
  121. (defmeth inspect-sequence-dialog-proto :inspect-selection ()
  122.   (let ((data (slot-value 'data))
  123.         (editable (slot-value 'editable))
  124.         (list-item (slot-value 'list-item)))
  125.     (inspect (elt data (send list-item :selection)) :editable editable)))
  126.  
  127. (defmeth inspect-sequence-dialog-proto :edit-selection ()
  128.   (let* ((data (slot-value 'data))
  129.          (i (send list-item :selection))
  130.          (v (get-value-dialog "New value for element")))
  131.     (when v 
  132.           (setf (elt data i) (car v))
  133.           (send list-item :set-text i (format nil "~s" (elt data i))))))
  134.  
  135. ;;;
  136. ;;;
  137. ;;; Inspect Matrix Dialog Proto
  138. ;;;
  139. ;;;
  140.  
  141. (defproto inspect-matrix-dialog-proto 
  142.   '(list-item columns) () inspect-dialog-proto)
  143.  
  144. (defmeth inspect-matrix-dialog-proto :isnew (d &key (title "Inspect") edit)
  145.   (if (not (matrixp d)) (error "not a matrix"))
  146.   (setf (slot-value 'columns) (min 3 (array-dimension d 1)))
  147.   (call-next-method d :title title :editable edit))
  148.  
  149. (defmeth inspect-matrix-dialog-proto :make-items ()
  150.   (let* ((data (slot-value 'data))
  151.          (columns (slot-value 'columns))
  152.          (strings (map-elements #'(lambda (x) (format nil "~s" x)) data)))
  153.     (setf (slot-value 'list-item) 
  154.           (send list-item-proto :new strings :columns columns
  155.                 :action    #'(lambda (double) 
  156.                             (if double (send self :inspect-selection)))))
  157.     (list (send text-item-proto :new
  158.                 (format nil "type:    ~s" (type-of data)))
  159.           (send text-item-proto :new
  160.                 (format nil "dimensions:  ~s" (array-dimensions data)))
  161.           (slot-value 'list-item))))
  162.  
  163. (defmeth inspect-matrix-dialog-proto :inspect-selection ()
  164.   (let ((data (slot-value 'data))
  165.         (columns (slot-value 'columns)))
  166.     (inspect (apply #'aref data (send (slot-value 'list-item) :selection)) 
  167.              :editable (slot-value 'editable))))
  168.  
  169. (defmeth inspect-matrix-dialog-proto :edit-selection ()
  170.   (let* ((data (slot-value 'data))
  171.          (i (send list-item :selection))
  172.          (v (get-value-dialog "New value for element")))
  173.     (when v 
  174.           (setf (aref data (car i) (cadr i)) (car v))
  175.           (send list-item :set-text i 
  176.                 (format nil "~s" (aref data (car i) (cadr i)))))))
  177.  
  178. ;;;
  179. ;;;
  180. ;;; Inspect Function
  181. ;;;
  182. ;;;
  183.  
  184. (defun inspect (x &rest args)
  185.   (cond ((symbolp x) (apply #'send inspect-symbol-dialog-proto :new x args))
  186.         ((or (consp x) (vectorp x))
  187.          (apply #'send inspect-sequence-dialog-proto :new x args))
  188.         ((matrixp x) (apply #'send inspect-matrix-dialog-proto :new x args))
  189.         (t (apply #'send inspect-dialog-proto :new x args))))    
  190.